home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH9 / SRC / PLATONIC.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-11-16  |  11.5 KB  |  347 lines
  1. VERSION 4.00
  2. Begin VB.Form PlatonicForm 
  3.    Appearance      =   0  'Flat
  4.    BackColor       =   &H00C0C0C0&
  5.    Caption         =   "Platonic Solids"
  6.    ClientHeight    =   4230
  7.    ClientLeft      =   1395
  8.    ClientTop       =   1425
  9.    ClientWidth     =   5850
  10.    BeginProperty Font 
  11.       name            =   "MS Sans Serif"
  12.       charset         =   1
  13.       weight          =   700
  14.       size            =   8.25
  15.       underline       =   0   'False
  16.       italic          =   0   'False
  17.       strikethrough   =   0   'False
  18.    EndProperty
  19.    ForeColor       =   &H80000008&
  20.    Height          =   4920
  21.    KeyPreview      =   -1  'True
  22.    Left            =   1335
  23.    LinkTopic       =   "Form1"
  24.    ScaleHeight     =   4230
  25.    ScaleWidth      =   5850
  26.    Top             =   795
  27.    Width           =   5970
  28.    Begin VB.CheckBox Choice 
  29.       Caption         =   "Dodecahedron"
  30.       Height          =   255
  31.       Index           =   4
  32.       Left            =   4320
  33.       TabIndex        =   4
  34.       TabStop         =   0   'False
  35.       Top             =   1560
  36.       Width           =   1575
  37.    End
  38.    Begin VB.CheckBox Choice 
  39.       Caption         =   "Icosahedron"
  40.       Height          =   255
  41.       Index           =   5
  42.       Left            =   4320
  43.       TabIndex        =   5
  44.       TabStop         =   0   'False
  45.       Top             =   1920
  46.       Width           =   1575
  47.    End
  48.    Begin VB.CheckBox Choice 
  49.       Caption         =   "Cube"
  50.       Height          =   255
  51.       Index           =   2
  52.       Left            =   4320
  53.       TabIndex        =   2
  54.       TabStop         =   0   'False
  55.       Top             =   840
  56.       Value           =   1  'Checked
  57.       Width           =   1575
  58.    End
  59.    Begin VB.CheckBox Choice 
  60.       Caption         =   "Octahedron"
  61.       Height          =   255
  62.       Index           =   3
  63.       Left            =   4320
  64.       TabIndex        =   3
  65.       TabStop         =   0   'False
  66.       Top             =   1200
  67.       Width           =   1575
  68.    End
  69.    Begin VB.CheckBox Choice 
  70.       Caption         =   "Axes"
  71.       Height          =   255
  72.       Index           =   0
  73.       Left            =   4320
  74.       TabIndex        =   0
  75.       TabStop         =   0   'False
  76.       Top             =   0
  77.       Value           =   1  'Checked
  78.       Width           =   1575
  79.    End
  80.    Begin VB.CheckBox Choice 
  81.       Caption         =   "Tetrahedron"
  82.       Height          =   255
  83.       Index           =   1
  84.       Left            =   4320
  85.       TabIndex        =   1
  86.       TabStop         =   0   'False
  87.       Top             =   480
  88.       Width           =   1575
  89.    End
  90.    Begin VB.PictureBox Pict 
  91.       AutoRedraw      =   -1  'True
  92.       Height          =   4215
  93.       Left            =   0
  94.       ScaleHeight     =   -4
  95.       ScaleLeft       =   -2
  96.       ScaleMode       =   0  'User
  97.       ScaleTop        =   2
  98.       ScaleWidth      =   4
  99.       TabIndex        =   6
  100.       Top             =   0
  101.       Width           =   4215
  102.    End
  103.    Begin VB.Menu mnuFile 
  104.       Caption         =   "&File"
  105.       Begin VB.Menu mnuFileExit 
  106.          Caption         =   "E&xit"
  107.       End
  108.    End
  109. Attribute VB_Name = "PlatonicForm"
  110. Attribute VB_Creatable = False
  111. Attribute VB_Exposed = False
  112. Option Explicit
  113. ' Location of viewing eye.
  114. Dim EyeR As Single
  115. Dim EyeTheta As Single
  116. Dim EyePhi As Single
  117. ' Location of focus point.
  118. Const FocusX = 0#
  119. Const FocusY = 0#
  120. Const FocusZ = 0#
  121. Dim Projector(1 To 4, 1 To 4) As Single
  122. Dim FirstTet As Integer
  123. Dim FirstCube As Integer
  124. Dim FirstOct As Integer
  125. Dim FirstDod As Integer
  126. Dim FirstIco As Integer
  127. Dim LastIco As Integer
  128. ' ***********************************************
  129. ' Project and draw the cube.
  130. ' ***********************************************
  131. Private Sub DrawData(pic As Object)
  132. Dim i As Integer
  133.     ' Transform the points.
  134.     TransformAllDataFull Projector
  135.     ' Draw the points.
  136.     pic.Cls
  137.     If Choice(0).value = vbChecked Then DrawSomeData pic, 1, FirstTet - 1, vbBlack, False
  138.     If Choice(1).value = vbChecked Then DrawSomeData pic, FirstTet, FirstCube - 1, vbRed, False
  139.     If Choice(2).value = vbChecked Then DrawSomeData pic, FirstCube, FirstOct - 1, RGB(0, 128, 0), False
  140.     If Choice(3).value = vbChecked Then DrawSomeData pic, FirstOct, FirstDod - 1, vbBlue, False
  141.     If Choice(4).value = vbChecked Then DrawSomeData pic, FirstDod, FirstIco - 1, vbMagenta, False
  142.     If Choice(5).value = vbChecked Then DrawSomeData pic, FirstIco, LastIco, RGB(0, 128, 128), False
  143.     pic.Refresh
  144. End Sub
  145. Private Sub Choice_Click(Index As Integer)
  146.     DrawData Pict
  147. End Sub
  148. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  149. Const Dtheta = PI / 20
  150.     Select Case KeyCode
  151.         Case vbKeyLeft
  152.             EyeTheta = EyeTheta - Dtheta
  153.         
  154.         Case vbKeyRight
  155.             EyeTheta = EyeTheta + Dtheta
  156.         
  157.         Case vbKeyUp
  158.             EyePhi = EyePhi - Dtheta
  159.         
  160.         Case vbKeyDown
  161.             EyePhi = EyePhi + Dtheta
  162.         
  163.         Case Else
  164.             Exit Sub
  165.     End Select
  166.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  167.     DrawData Pict
  168. End Sub
  169. Private Sub Form_Load()
  170.     ' Initialize the eye position.
  171.     EyeR = 5
  172.     EyeTheta = PI * 0.4
  173.     EyePhi = PI * 0.1
  174.     ' Initialize the projection transformation.
  175.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  176.     ' Create the data.
  177.     CreateData
  178.     ' Project and draw the data.
  179.     DrawData Pict
  180. End Sub
  181. Sub CreateData()
  182. Dim theta1 As Single
  183. Dim theta2 As Single
  184. Dim s1 As Single
  185. Dim s2 As Single
  186. Dim c1 As Single
  187. Dim c2 As Single
  188. Dim S As Single
  189. Dim R As Single
  190. Dim H As Single
  191. Dim A As Single
  192. Dim B As Single
  193. Dim C As Single
  194. Dim D As Single
  195. Dim x As Single
  196. Dim y As Single
  197. Dim y2 As Single
  198. Dim M As Single
  199. Dim N As Single
  200. Dim i As Integer    '@
  201.     ' Axes.
  202.     MakeSegment 0, 0, 0, 0.5, 0, 0  ' X axis.
  203.     MakeSegment 0, 0, 0, 0, 0.5, 0  ' Y axis.
  204.     MakeSegment 0, 0, 0, 0, 0, 0.5  ' Z axis.
  205.     ' Tetrahedron.
  206.     FirstTet = NumSegments + 1
  207.     S = Sqr(6)
  208.     A = S / Sqr(3)
  209.     B = -A / 2
  210.     C = A * Sqr(2) - 1
  211.     D = S / 2
  212.     MakeSegment 0, C, 0, A, -1, 0
  213.     MakeSegment 0, C, 0, B, -1, D
  214.     MakeSegment 0, C, 0, B, -1, -D
  215.     MakeSegment B, -1, -D, B, -1, D
  216.     MakeSegment B, -1, D, A, -1, 0
  217.     MakeSegment A, -1, 0, B, -1, -D
  218.     ' Cube.
  219.     FirstCube = NumSegments + 1
  220.     MakeSegment -1, -1, -1, -1, 1, -1
  221.     MakeSegment -1, 1, -1, 1, 1, -1
  222.     MakeSegment 1, 1, -1, 1, -1, -1
  223.     MakeSegment 1, -1, -1, -1, -1, -1
  224.     MakeSegment -1, -1, 1, -1, 1, 1
  225.     MakeSegment -1, 1, 1, 1, 1, 1
  226.     MakeSegment 1, 1, 1, 1, -1, 1
  227.     MakeSegment 1, -1, 1, -1, -1, 1
  228.     MakeSegment -1, -1, -1, -1, -1, 1
  229.     MakeSegment -1, 1, -1, -1, 1, 1
  230.     MakeSegment 1, 1, -1, 1, 1, 1
  231.     MakeSegment 1, -1, -1, 1, -1, 1
  232.     ' Octahedron.
  233.     FirstOct = NumSegments + 1
  234.     MakeSegment 0, 1, 0, 1, 0, 0
  235.     MakeSegment 0, 1, 0, -1, 0, 0
  236.     MakeSegment 0, 1, 0, 0, 0, 1
  237.     MakeSegment 0, 1, 0, 0, 0, -1
  238.     MakeSegment 0, -1, 0, 1, 0, 0
  239.     MakeSegment 0, -1, 0, -1, 0, 0
  240.     MakeSegment 0, -1, 0, 0, 0, 1
  241.     MakeSegment 0, -1, 0, 0, 0, -1
  242.     MakeSegment 0, 0, 1, 1, 0, 0
  243.     MakeSegment 0, 0, 1, -1, 0, 0
  244.     MakeSegment 0, 0, -1, 1, 0, 0
  245.     MakeSegment 0, 0, -1, -1, 0, 0
  246.     ' Dodecahedron.
  247.     FirstDod = NumSegments + 1
  248.     theta1 = PI * 0.4
  249.     theta2 = PI * 0.8
  250.     s1 = Sin(theta1)
  251.     c1 = Cos(theta1)
  252.     s2 = Sin(theta2)
  253.     c2 = Cos(theta2)
  254.     M = 1 - (2 - 2 * c1 - 4 * s1 * s1) / (2 * c1 - 2)
  255.     N = Sqr((2 - 2 * c1) - M * M) * (1 + (1 - c2) / (c1 - c2))
  256.     R = 2 / N
  257.     S = R * Sqr(2 - 2 * c1)
  258.     A = R * s1
  259.     B = R * s2
  260.     C = R * c1
  261.     D = R * c2
  262.     H = R * (c1 - s1)
  263.     x = (R * R * (2 - 2 * c1) - 4 * A * A) / (2 * C - 2 * R)
  264.     y = Sqr(S * S - (R - x) * (R - x))
  265.     y2 = y * (1 - c2) / (c1 - c2)
  266.     MakeSegment R, 1, 0, C, 1, A        ' Top
  267.     MakeSegment C, 1, A, D, 1, B
  268.     MakeSegment D, 1, B, D, 1, -B
  269.     MakeSegment D, 1, -B, C, 1, -A
  270.     MakeSegment C, 1, -A, R, 1, 0
  271.     MakeSegment R, 1, 0, x, 1 - y, 0    ' Top downward edges.
  272.     MakeSegment C, 1, A, x * c1, 1 - y, x * s1
  273.     MakeSegment C, 1, -A, x * c1, 1 - y, -x * s1
  274.     MakeSegment D, 1, B, x * c2, 1 - y, x * s2
  275.     MakeSegment D, 1, -B, x * c2, 1 - y, -x * s2
  276.     MakeSegment x, 1 - y, 0, -x * c2, 1 - y2, -x * s2   ' Middle.
  277.     MakeSegment x, 1 - y, 0, -x * c2, 1 - y2, x * s2
  278.     MakeSegment x * c1, 1 - y, x * s1, -x * c2, 1 - y2, x * s2
  279.     MakeSegment x * c1, 1 - y, x * s1, -x * c1, 1 - y2, x * s1
  280.     MakeSegment x * c2, 1 - y, x * s2, -x * c1, 1 - y2, x * s1
  281.     MakeSegment x * c2, 1 - y, x * s2, -x, 1 - y2, 0
  282.     MakeSegment x * c2, 1 - y, -x * s2, -x, 1 - y2, 0
  283.     MakeSegment x * c2, 1 - y, -x * s2, -x * c1, 1 - y2, -x * s1
  284.     MakeSegment x * c1, 1 - y, -x * s1, -x * c1, 1 - y2, -x * s1
  285.     MakeSegment x * c1, 1 - y, -x * s1, -x * c2, 1 - y2, -x * s2
  286.         
  287.     MakeSegment -R, -1, 0, -x, 1 - y2, 0    ' Bottom upward edges.
  288.     MakeSegment -C, -1, A, -x * c1, 1 - y2, x * s1 ' Bottom upward edges.
  289.     MakeSegment -D, -1, B, -x * c2, 1 - y2, x * s2
  290.     MakeSegment -D, -1, -B, -x * c2, 1 - y2, -x * s2
  291.     MakeSegment -C, -1, -A, -x * c1, 1 - y2, -x * s1
  292.     MakeSegment -R, -1, 0, -C, -1, A    ' Bottom
  293.     MakeSegment -C, -1, A, -D, -1, B
  294.     MakeSegment -D, -1, B, -D, -1, -B
  295.     MakeSegment -D, -1, -B, -C, -1, -A
  296.     MakeSegment -C, -1, -A, -R, -1, 0
  297.     ' Icosahedron.
  298.     FirstIco = NumSegments + 1
  299.     A = 2 - 2 * c1
  300.     R = 2 / (2 * Sqr(1 - 2 * c1) + Sqr(3 / 4 * (2 - 2 * c1) - 2 * c2 - c2 * c2 - 1))
  301.     S = R * Sqr(2 - 2 * c1)
  302.     H = 1 - Sqr(S * S - R * R)
  303.     A = R * s1
  304.     B = R * s2
  305.     C = R * c1
  306.     D = R * c2
  307.     MakeSegment R, H, 0, C, H, A        ' Top
  308.     MakeSegment C, H, A, D, H, B
  309.     MakeSegment D, H, B, D, H, -B
  310.     MakeSegment D, H, -B, C, H, -A
  311.     MakeSegment C, H, -A, R, H, 0
  312.     MakeSegment R, H, 0, 0, 1, 0        ' Point
  313.     MakeSegment C, H, A, 0, 1, 0
  314.     MakeSegment D, H, B, 0, 1, 0
  315.     MakeSegment D, H, -B, 0, 1, 0
  316.     MakeSegment C, H, -A, 0, 1, 0
  317.     MakeSegment -R, -H, 0, -C, -H, A    ' Bottom
  318.     MakeSegment -C, -H, A, -D, -H, B
  319.     MakeSegment -D, -H, B, -D, -H, -B
  320.     MakeSegment -D, -H, -B, -C, -H, -A
  321.     MakeSegment -C, -H, -A, -R, -H, 0
  322.     MakeSegment -R, -H, 0, 0, -1, 0     ' Point
  323.     MakeSegment -C, -H, A, 0, -1, 0
  324.     MakeSegment -D, -H, B, 0, -1, 0
  325.     MakeSegment -D, -H, -B, 0, -1, 0
  326.     MakeSegment -C, -H, -A, 0, -1, 0
  327.     MakeSegment R, H, 0, -D, -H, B      ' Middle
  328.     MakeSegment R, H, 0, -D, -H, -B
  329.     MakeSegment C, H, A, -D, -H, B
  330.     MakeSegment C, H, A, -C, -H, A
  331.     MakeSegment D, H, B, -C, -H, A
  332.     MakeSegment D, H, B, -R, -H, 0
  333.     MakeSegment D, H, -B, -R, -H, 0
  334.     MakeSegment D, H, -B, -C, -H, -A
  335.     MakeSegment C, H, -A, -C, -H, -A
  336.     MakeSegment C, H, -A, -D, -H, -B
  337.     LastIco = NumSegments
  338.     If Not SameSideLengths(FirstTet, FirstCube - 1) Then MsgBox "Error in tetrahedron."
  339.     If Not SameSideLengths(FirstCube, FirstOct - 1) Then MsgBox "Error in cube."
  340.     If Not SameSideLengths(FirstOct, FirstDod - 1) Then MsgBox "Error in octahedron."
  341.     If Not SameSideLengths(FirstDod, FirstIco - 1) Then MsgBox "Error in dodecahedron."
  342.     If Not SameSideLengths(FirstIco, LastIco - 1) Then MsgBox "Error in icosahedron."
  343. End Sub
  344. Private Sub mnuFileExit_Click()
  345.     Unload Me
  346. End Sub
  347.